Linux Cubed Series 2: Applications

home *** CD-ROM | disk | FTP | other *** search

/ Linux Cubed Series 2: Applications / Linux Cubed Series 2 - Applications.iso / editors / emacs / xemacs / xemacs-1.006 / xemacs-1 / lib / xemacs-19.13 / lisp / utils / xpm-button.el < prev next >

Wrap

Text File | 1995-08-31 | 23.8 KB | 485 lines

;;; Create XPM text buttons under XEmacs (requires 19.12 or beyond) ;;; Copyright (C) 1995 Kyle E. Jones ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 1, or (at your option) ;;; any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; A copy of the GNU General Public License can be obtained from this ;;; program's author (send electronic mail to kyle@uunet.uu.net) or from ;;; the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA ;;; 02139, USA. ;;; ;;; Send bug reports to kyle@wonderworks.com ;;; The sole interface function is xpm-button-create. (provide 'xpm-button) (defvar xpm-button-version "1.01" "Version string for xpm-button.") (defvar xpm-button-vertical-padding 3 "Number of pixels between the text and the top/bottom of the button.") (defvar xpm-button-horizontal-padding 3 "Number of pixels between the text and the left/right edges of the button.") (defvar xpm-button-font-pixel-lines '( " xx xxxxxx xxxx x xxxxxxx xxxxxxxx xxxxxxxx xxxx x xxxx xxxx xxxx xxxx xxxx xxxx xxxx xxxx xxxx xxx xxx xxxxx xxxxxxx xxxxx xxxxxxx xxxx x xxxxxxxx xxxx xxx xxxx xxx xxxx xxxx xxx xxxx xxxx xxxx xxx xxxxxxxx xxx xxx xxx xxx xx xx xxx xxx x xx x xxxx xxxx xxx xxxxx xxx xxxxxx xxxx xxxx x xx xxxx x x xxxx xx x x xxx x x x xxxx xx xxxx xx xx x x x xxxx x x " " xx xx xx xx xx xx xx xx xx xx xx xx xx xx xx xx xx xx x xx xxx xxx xxx x xx xx xx xx xx xx xx xx xx xx xx xx xx xx x xx x xx xx x xx x xx x xx xxx xx xx xx x xx xx xx xx xx xx x x xxx xx xx xx xx xxx xxxx x xx xxxxxx xx xx xx xx x xx xx x x x xx xxx xx xxxx x xx x x x x x x xx xx xx xx xx x x x xx xx xx x " " x xx xx xx xx x xx xx xx x xx x xx x xx xx xx xx xx x xx xxx xxx xxxx x xx xx xx xx xx xx xx xx xx x x xx x xx x xx x xx xx x xxx x xx x x xxx xx xx xx xx xx xx xx xx xx xx xx xx xx xx xx x xx x xx xx x x xx x xx xx xx xx x xxxx x xxxxxx x x xx x x xxx xx x xxx xx xx x xx xx xx xx x x x x xx xx x x " " x xx xx xx xx x xx xx xx x xx x x xx x xx xx xx xx xx x xx x xx x xx x xxx x xx xx xx xx xx xx xx xx xxxx x xx x xx x xx x xx x xx x xxxx xx x xxx xxxx xx xx xxx xx xx xxx xxxxx xxxx xx xx xxx xxx xx xxx xx xxx xx xx xxx xx xxx xxx xx xx xx xxx xx xxxx xxxxx xxx xxx xxxx xxx xxx xxxx xxx xxx xxx xxxx xxx xxxxxx xx xx xx xx xx x xx xxxx xx xx xx x xx xx xx xx x x xx x x x xx x xx x x xx x x xx xxx x x x x x x xx xx xx xx xx xx x xx xx xx xx xx x " " x xx xxxxx xx xx xx xxxxx xxxxx xx xxxxxxxx xx xx xxxxx xx x xx x xx x xxx x xx xx xx xx xx xx xxxxx xxxxx xx xx x xx x xx x xx x xxx xx x xx x xx xxx xxx xxx xx xxx xxx xxx xx xx xx xx xxx xx xx xx xx xx xx xxx xxx xx xxx xx xxx xxx xxx xxx xxx xxx xxxxx x x xx xx xx xx x xx xx x xx x xx x x xxx xx xx xx xx xx x xx x xx xxxxx xx xxxx xxxxx xx x xx x xx xx x x x xxxx xx x x xx x xx xx xxxx x x xx xx xxxxxx x xx x xx x xx xx xxx xxx x xx x x " " xxxxxx xx xx xx xx xx xx x xx x xx xxxx xx xx xx xx xx xxx xx x xx x xx x xxxx xx xx xxxxx xx xx xx xx xx xxxx xx xx x xx x xx x xx x x xxx xx xxx xxxx xx xx xx xx xx xxxxxx xx xx xx xx xx xx xx xxxx xx xx xx xx xx xx xx xx xx xx xx xx xx xxxx xx xx xx xx x xx xxx x xxx xx x xxx xx xx xx xx xx x xx xx xx xx xx x xxx xx xxxxxx xx x xx xx x xxxxxx xxx xx x xx x x x x xxxx xx xx xxxxxx xxxxxxx xx x xx x xxx xxx xx x xx x " " x xx xx xx xx x xx xx xx x xx xx xx xx xx xx xx xx xx xx xx x x xx xx x xxx xx xx xx xxx x xx xx xx x xx xx xx x xx x xx xx x xxx xx xxx x xx xx xx xx xx xx xx xx xx xxxx xx xx xx xx xx xx xx xx xx xx xx xx xx xx xx xx xx xx xx xxxx xx xx xx xx x xx xxx x xxx xx x xxx xx xx xx x x xx xx xxxxxx xx xx xx xx xx x xx xx xx x xx x xx xx x x xx x x x xx x xx xxx xx xx xxxxxx x xx x xx x xxx xxx x x x " " x xx xx xx xx xx xx xx xx xx xx xx xx xx xx xx xx xx xx xxx xx xx x xx xx x xx xx xx xx xx xxx xx xxx xx xx xx xxx xx xx xx xx x xx xx xxx xx xx xxx xx xxx xxx xx xxx xxx xxx xx xx x xx xx xx xx xx xx xx xx xx xx xx xx xxx xxx xxx xxx xxx xxx xx x x xx xx xxx xx xx xx x xx xx xxx x x x xx xxxxxx xx xx xx xx xx xx xx xx xx xx xx x xx x x x x xx x x x xx x xxx xxxxx x x x xx xx xx xx xx xx xx xx xx xx x xx xx x " "xxx xxxx xxxxxxx xxxxx xxxxxxx xxxxxxxx xxxx xxxx x xxxx xxxx xxxx xxx xxxx xxx xxxxxxxx xxx xx xxxx xxx x xxxxx xxxx xxxxx xxxx xx x xxxx xxxx xxxxx xx xx xx xxx xxxx xxxx xxxxxxxx xx xxx x xxx xxx xx xxx xxx xxxx xxxxxx xxxx xxx xxxx xx xxxx xxx xxxx xxxx xxx xxx xxxx xxx xxx xx xx xx xx xxxx xxxx xx xx xxx xx xx xx xxx xxx xx xxxxxx xx xxxx xxxxxx xxxx xxxx xxxx xxxx xx xxxx xxx xx xxxxxx x x xxxx x xx xxxx xx xx xx x xx xx xx xx xx xx xx xx x xx x x " " xxxx xxxxxx xx xx xx x x x x xx xx xx xx x x " " xx x xx xx xx xx xxx x x xxxxxxx xxxx xx xxxx xx x x " " xxxxx xx xxxx xxxx xx " ) "List of strings representing pixel lines for the button font.") (defvar xpm-button-font-line-indices '(("A" 0 10) ("B" 11 19) ("C" 20 28) ("D" 29 38) ("E" 39 47) ("F" 48 56) ("G" 57 66) ("H" 67 77) ("I" 78 82) ("J" 83 90) ("K" 91 100) ("L" 101 109) ("M" 110 121) ("N" 122 132) ("O" 133 142) ("P" 143 151) ("Q" 152 162) ("R" 163 172) ("S" 173 180) ("T" 181 189) ("U" 190 199) ("V" 200 210) ("W" 211 224) ("X" 225 234) ("Y" 235 243) ("Z" 244 252) ("a" 253 260) ("b" 261 269) ("c" 270 276) ("d" 277 285) ("e" 286 292) ("f" 293 298) ("g" 299 306) ("h" 307 315) ("i" 316 320) ("j" 321 324) ("k" 325 333) ("l" 334 338) ("m" 339 351) ("n" 352 360) ("o" 361 368) ("p" 369 377) ("q" 378 386) ("r" 387 393) ("s" 394 399) ("t" 400 405) ("u" 406 414) ("v" 415 423) ("w" 424 436) ("x" 437 444) ("y" 445 453) ("z" 454 460) ("0" 461 467) ("1" 468 472) ("2" 473 479) ("3" 480 486) ("4" 487 493) ("5" 494 500) ("6" 501 507) ("7" 508 514) ("8" 515 521) ("9" 522 528) ("`" 529 531) ("~" 532 538) ("!" 539 541) ("@" 542 552) ("#" 553 560) ("$" 561 567) ("%" 568 580) ("^" 581 586) ("&" 587 597) ("*" 598 603) ("(" 604 608) (")" 609 613) ("-" 614 620) ("_" 621 628) ("=" 629 635) ("+" 636 643) ("[" 644 648) ("{" 649 653) ("]" 654 658) ("}" 659 663) (";" 664 666) (":" 667 669) ("'" 670 672) ("\"" 673 676) ("," 677 679) ("<" 680 686) ("." 687 689) (">" 690 696) ("/" 697 700) ("?" 701 707) ("\\" 708 713) ("|" 714 715) (" " 716 719)) "Indices into the xpm-button-font-pixel-lines strings for each character. Format is (STR START END) STR contains the character. START is where the character's pixels start in each string of xpm-button-font-pixel-lines (0 is the index of the first pixel). END is the index of the position after the last pixel of the character.") (defun xpm-button-lookup-rgb-components (color) "Lookup COLOR (a color name) in rgb.txt and return a list of RGB values. The list (R G B) is returned, or an error is signaled if the lookup fails." (let ((lib-list x-library-search-path) file r g b) (while lib-list (setq file (expand-file-name "rgb.txt" (car lib-list))) (if (file-readable-p file) (setq lib-list nil) (setq lib-list (cdr lib-list) file nil))) (if (null file) (error "xpm-button-lookup-rgb-components: Can't find rgb.txt file.") (save-excursion (set-buffer (find-file-noselect file)) (save-excursion (save-restriction (widen) (goto-char (point-min)) (or (re-search-forward (format "\t%s$" (regexp-quote color)) nil t) (error "No such color: %s")) (beginning-of-line) (setq r (* (read (current-buffer)) 256) g (* (read (current-buffer)) 256) b (* (read (current-buffer)) 256)) (list r g b) )))))) (defun xpm-button-hex-string-to-number (string) "Convert STRING to an integer by parsing it as a hexadecimal number." (let ((conv-list '((?0 . 0) (?a . 10) (?A . 10) (?1 . 1) (?b . 11) (?B . 11) (?2 . 2) (?c . 12) (?C . 12) (?3 . 3) (?d . 13) (?D . 13) (?4 . 4) (?e . 14) (?E . 14) (?5 . 5) (?f . 15) (?F . 15) (?6 . 6) (?7 . 7) (?8 . 8) (?9 . 9))) (n 0) (i 0) (lim (length string))) (while (< i lim) (setq n (+ (* n 16) (or (cdr (assq (aref string i) conv-list)) 0)) i (1+ i))) n )) (defun xpm-button-parse-rgb-components (color) "Parse RGB color specification and return a list of integers (R G B). #FEFEFE and rgb:fe/fe/fe style specifications are parsed." (let ((case-fold-search t) r g b str) (cond ((string-match "^#[0-9a-f]+$" color) (cond ((= (length color) 4) (setq r (xpm-button-hex-string-to-number (substring color 1 2)) g (xpm-button-hex-string-to-number (substring color 2 3)) b (xpm-button-hex-string-to-number (substring color 3 4)) r (* r 4096) g (* g 4096) b (* b 4096))) ((= (length color) 7) (setq r (xpm-button-hex-string-to-number (substring color 1 3)) g (xpm-button-hex-string-to-number (substring color 3 5)) b (xpm-button-hex-string-to-number (substring color 5 7)) r (* r 256) g (* g 256) b (* b 256))) ((= (length color) 10) (setq r (xpm-button-hex-string-to-number (substring color 1 4)) g (xpm-button-hex-string-to-number (substring color 4 7)) b (xpm-button-hex-string-to-number (substring color 7 10)) r (* r 16) g (* g 16) b (* b 16))) ((= (length color) 13) (setq r (xpm-button-hex-string-to-number (substring color 1 5)) g (xpm-button-hex-string-to-number (substring color 5 9)) b (xpm-button-hex-string-to-number (substring color 9 13)))) (t (error "Invalid RGB color specification: %s" color)))) ((string-match "rgb:\$[0-9a-f]+\$/\$[0-9a-f]+\$/\$[0-9a-f]+\$" color) (if (or (> (- (match-end 1) (match-beginning 1)) 4) (> (- (match-end 2) (match-beginning 2)) 4) (> (- (match-end 3) (match-beginning 3)) 4)) (error "Invalid RGB color specification: %s" color) (setq str (match-string 1 color) r (* (xpm-button-hex-string-to-number str) (expt 16 (- 4 (length str)))) str (match-string 2 color) g (* (xpm-button-hex-string-to-number str) (expt 16 (- 4 (length str)))) str (match-string 3 color) b (* (xpm-button-hex-string-to-number str) (expt 16 (- 4 (length str))))))) (t (error "Invalid RGB color specification: %s" color))) (list r g b) )) (defun xpm-button-color-rgb-components (color) "Return the RGB components of COLOR as a list of integers (R G B). 16-bit values are always returned. #FEFEFE and rgb:fe/fe/fe style color specifications are parsed directly into their components. RGB values for color names are looked up in the rgb.txt file. The variable x-library-search-path is use to locate the rgb.txt file." (if (let ((case-fold-search t)) (or (string-match "^#" color) (string-match "^rgb:" color))) (xpm-button-parse-rgb-components color) (xpm-button-lookup-rgb-components color))) (defun xpm-button-compute-contrast-color (color) "Compute a contrasting color for COLOR. The new color is created by xor-ing the RGB values of COLOR with all ones." (let* ((rgb (xpm-button-color-rgb-components color)) (r (logxor (nth 0 rgb) 65535)) (g (logxor (nth 1 rgb) 65535)) (b (logxor (nth 2 rgb) 65535))) (format "rgb:%04x/%04x/%04x" r g b))) (defun xpm-button-compute-shadow-colors (color) "Compute shadow colors for COLOR. COLOR should be a string naming a color. Returns (COLOR1 . COLOR2) where COLOR1 is the brighter shadow color and COLOR2 is the dimmer color." (let* ((rgb (xpm-button-color-rgb-components color)) (r (nth 0 rgb)) (g (nth 1 rgb)) (b (nth 2 rgb)) (bright-r (/ (* r 12) 10)) (bright-g (/ (* g 12) 10)) (bright-b (/ (* b 12) 10)) (dim-r (/ (* r 8) 10)) (dim-g (/ (* g 8) 10)) (dim-b (/ (* b 8) 10))) (if (> bright-r 65535) (setq bright-r 65535)) (if (> bright-g 65535) (setq bright-g 65535)) (if (> bright-b 65535) (setq bright-b 65535)) (cons (format "rgb:%04x/%04x/%04x" bright-r bright-g bright-b) (format "rgb:%04x/%04x/%04x" dim-r dim-g dim-b)))) (defun xpm-button-create (text shadow-thickness fg-color bg-color) "Returns a list of XPM image instantiators for a button displaying TEXT. The list is of the form (UP DOWN DISABLED) where UP, DOWN, and DISABLED are the up, down and disabled image instantiators for the button. SHADOW-THICKNESS specifies how many pixels should be used for the shadows on the edges of the buttons. It should be a positive integer, or 0 to mean no shadows on the edges. FG-COLOR is the color used to display the text. It should be a string. BG-COLOR is the background color the text will be displayed upon. It should be a string." (save-excursion (set-buffer (get-buffer-create " xpm-button")) (erase-buffer) ;; create the correct number of lines for the pixels for the ;; characters. (insert-char ?\n (length xpm-button-font-pixel-lines)) (let ((i 0) (str (make-string 1 0)) (lim (length text)) (bg-char ? ) font-pixel-lines q) ;; loop through text, adding the character pixels (while (< i lim) (aset str 0 (aref text i)) (if (null (setq q (assoc str xpm-button-font-line-indices))) nil ; no pixel data for this character (goto-char (point-min)) (setq font-pixel-lines xpm-button-font-pixel-lines) (while font-pixel-lines (end-of-line) (if (not (bolp)) ;; Insert space before some of the characters. ;; This isn't really correct for this font ;; but doing it right is too hard. ;; This isn't TeX after all. (if (memq (aref str 0) '(?, ?. ?\" ?! ?| ?\' ?\`)) (insert-char bg-char 1)) ;; offset the start a bit from the left edge of the button (insert-char bg-char xpm-button-horizontal-padding)) ;; insert the character pixels. (insert (substring (car font-pixel-lines) (nth 1 q) (nth 2 q))) (forward-line) (setq font-pixel-lines (cdr font-pixel-lines)))) (setq i (1+ i))) ;; now offset the text from the right edge of the button. (goto-char (point-min)) (while (not (eobp)) (end-of-line) (insert-char bg-char xpm-button-horizontal-padding) (forward-line))) (let ((bright-char ?b) (dim-char ?d) (fg-char ?x) (bg-char ? ) (shadow-colors (xpm-button-compute-shadow-colors bg-color)) i len up-string down-string disabled-string) ;; find the length of a pixel line. (goto-char (point-min)) (end-of-line) (setq len (- (point) (point-min))) ;; offset text from the top of the button (goto-char (point-min)) (setq i xpm-button-vertical-padding) (while (> i 0) (insert-char bg-char len) (insert ?\n) (setq i (1- i))) ;; offset text from the bottom of the button (goto-char (point-max)) (setq i xpm-button-vertical-padding) (while (> i 0) (insert-char bg-char len) (insert ?\n) (setq i (1- i))) ;; add shadows to the pixel lines (goto-char (point-min)) (while (not (eobp)) (insert-char bright-char shadow-thickness) (end-of-line) (insert-char dim-char shadow-thickness) (forward-line)) ;; add top and bottom shadow lines (setq i shadow-thickness) (goto-char (point-min)) (while (> i 0) (insert-char bright-char (+ len shadow-thickness i)) (insert-char dim-char (- shadow-thickness i)) (insert ?\n) (setq i (1- i))) (setq i shadow-thickness) (goto-char (point-max)) (while (> i 0) (insert-char bright-char i) (insert-char dim-char (+ len (* 2 shadow-thickness) (- i))) (insert ?\n) (setq i (1- i))) ;; add doublequotes, commas and XPM header goop. (goto-char (point-min)) (while (not (eobp)) (insert "\"") (end-of-line) (insert "\",") (forward-line)) (insert "};\n") (goto-char (point-min)) ;; color map for the UP button (insert (format "/* XPM */ static char * button_xpm[] = { \"%d %d 4 1\", \"%c c %s\", \"%c c %s\", \"%c c %s\", \"%c c %s\", " (+ len (* shadow-thickness 2)) (+ (* xpm-button-vertical-padding 2) (* shadow-thickness 2) (length xpm-button-font-pixel-lines)) fg-char fg-color bg-char bg-color bright-char (car shadow-colors) dim-char (cdr shadow-colors))) (setq up-string (buffer-string)) (delete-region (point-min) (point)) ;; color map for the DOWN button (insert (format "/* XPM */ static char * button_xpm[] = { \"%d %d 4 1\", \"%c c %s\", \"%c c %s\", \"%c c %s\", \"%c c %s\", " (+ len (* shadow-thickness 2)) (+ (* xpm-button-vertical-padding 2) (* shadow-thickness 2) (length xpm-button-font-pixel-lines)) fg-char (xpm-button-compute-contrast-color fg-color) bg-char bg-color bright-char (cdr shadow-colors) dim-char (car shadow-colors))) (setq down-string (buffer-string)) (delete-region (point-min) (point)) ;; color map for the DISABLED button (insert (format "/* XPM */ static char * button_xpm[] = { \"%d %d 4 1\", \"%c c %s\", \"%c c %s\", \"%c c %s\", \"%c c %s\", " (+ len (* shadow-thickness 2)) (+ (* xpm-button-vertical-padding 2) (* shadow-thickness 2) (length xpm-button-font-pixel-lines)) fg-char fg-color bg-char bg-color bright-char (car shadow-colors) dim-char (cdr shadow-colors))) ;; stipple the foreground pixels (let ((str (make-string 1 0)) (bit 0) lim line-start) (aset str 0 fg-char) (while (not (eobp)) (setq lim (save-excursion (end-of-line) (point)) line-start (point)) (while (search-forward str lim t) (if (= (% (- (point) line-start) 2) bit) (subst-char-in-region (1- (point)) (point) fg-char bg-char t))) (if (zerop bit) (setq bit 1) (setq bit 0)) (forward-line))) (setq disabled-string (buffer-string)) (list (vector 'xpm ':data up-string) (vector 'xpm ':data down-string) (vector 'xpm ':data disabled-string)) )))